#lang racket


(require "../base/main.rkt")

(require "parametric.rkt")

(provide t-fn-min
         t-fn-half
         t-fn-max
         
         u-fn-min
         u-fn-half
         u-fn-max
         
         v-fn-min
         v-fn-half
         v-fn-max
         
         cut-fn-linear
         cut-fn-integral
         
         ; interval
         (struct-out interval)
         make-interval
         
         ; domain
         (struct-out domain)
         
         (struct-out t-domain)
         make-t-domain
         
         domain-t-min-s
         domain-t-min-val
         domain-t-max-s
         domain-t-max-val
         
         (struct-out uv-domain)
         make-uv-domain
         
         domain-u-min-s
         domain-u-min-val
         domain-u-max-s
         domain-u-max-val
         
         domain-v-min-s
         domain-v-min-val
         domain-v-max-s
         domain-v-max-val
         
         
         ;cut
         cut-t-domain
         cut-uv-domain
         cut-domain
         
         points-t-domain
         points-uv-domain
         points-domain)


; interval

;; cut-fn

(define (range-a-s-n a step n)
  (define (range-a-s-n-aux a n)
    (if (<= n 0)
        (list)
        (cons a (range-a-s-n-aux (+ a step) (- n 1)))))
  (range-a-s-n-aux a n))

(define (cut-fn-linear)
  (λ (interval n-segments)
    (let* ((min (interval-min-val interval))
           (max (interval-max-val interval))
           (n-points (+ n-segments 1))
           (step (/ (- max min) n-points))
           (first-interval (make-interval (interval-min-s interval) min 'closed (+ min step)))
           (last-interval (make-interval 'closed (- max step) (interval-max-s interval) max)))
      (append
       (list first-interval)
       (map 
        (λ (val)
          (make-interval 'closed val 'closed (+ val step)))
        (rest (butlast (range-a-s-n min step n-segments))))
       (list last-interval)))))

; edit
(define (cut-fn-integral)
  (λ (interval n-segments)
    (error 'cut-fn-integral "Closure not implemented")))


;; t-fn

(define (t-fn-min)
  (λ (interval)
    (when (eq? (interval-min-s interval) 'open)
      (raise unsupported "Min strategy is not applicable to an interval with an open lower bound"))
    (interval-min-val interval)))

(define (t-fn-half)
  (λ (interval)
    (let ((a (interval-min-val interval))
          (b (interval-max-val interval)))
      (/2 (+ a b)))))

(define (t-fn-max)
  (λ (interval)
    (when (eq? (interval-max-s interval) 'open)
      (raise unsupported "Max strategy is not applicable to an interval with an open upper bound"))
    (interval-max-val interval)))

(define u-fn-min t-fn-min)
(define u-fn-half t-fn-half)
(define u-fn-max t-fn-max)

(define v-fn-min t-fn-min)
(define v-fn-half t-fn-half)
(define v-fn-max t-fn-max)


;; struct

(define (interval-print interval port mode)
  (if (eq? (interval-min-s interval) 'open)
      (write-string "]" port)
      (write-string "[" port))
  (write-string (format "~a" (interval-min-val interval)) port)
  (write-string " " port)
  (write-string (format "~a" (interval-max-val interval)) port)
  (if (eq? (interval-max-s interval) 'open)
      (write-string "[" port)
      (write-string "]" port)))

(define-struct interval
  (min-s min-val max-s max-val)
  #:constructor-name new-interval
  #:property prop:custom-write interval-print)

(define (make-interval min-s min-val max-s max-val)
  (when (> min-val max-val)
      (error 'make-interval "Min val is greater than max val"))
  (new-interval min-s min-val max-s max-val))

(define (cut-interval int n-intervals cut-fn)
  (match int
    ((struct interval ('open _ 'open _))
     (rest (cut-fn int (+ n-intervals 1))))
    ((struct interval ('open _ 'closed max-val))
     (append
      (rest (cut-fn int n-intervals))
      (list (make-interval 'closed max-val 'closed max-val))))
    ((struct interval ('closed _ 'open _))
     (cut-fn int n-intervals))
    ((struct interval ('closed _ 'closed max-val))
     (if (= n-intervals 1)
         int
         (append
          (cut-fn int (- n-intervals 1))
          (list (make-interval 'closed max-val 'closed max-val)))))))

(define (points-interval interval n-points t-fn cut-fn)
  (map t-fn (cut-interval interval n-points cut-fn)))

; domain

(define-struct domain ())


;; t-domain

(define (t-domain-print domain port mode)
  (write (t-domain-t domain) port))

(define-struct (t-domain domain)
  (t)
  #:constructor-name new-t-domain
  #:property prop:custom-write t-domain-print)

(define (make-t-domain min-s min-val max-s max-val)
  (new-t-domain (make-interval min-s min-val max-s max-val)))


(define (domain-t-min-s t-domain)
  (interval-min-s (t-domain-t t-domain)))

(define (domain-t-min-val t-domain)
  (interval-min-val (t-domain-t t-domain)))

(define (domain-t-max-s t-domain)
  (interval-max-s (t-domain-t t-domain)))

(define (domain-t-max-val t-domain)
  (interval-max-val (t-domain-t t-domain)))


;; uv-domain

(define (uv-domain-print domain port mode)
  (write-string "(" port)
  (write (uv-domain-u domain) port)
  (write-string "," port)
  (write (uv-domain-v domain) port)
  (write-string ")" port))

(define-struct (uv-domain domain)
  (u v)
  #:constructor-name new-uv-domain
  #:property prop:custom-write uv-domain-print)

(define (make-uv-domain u-min-s u-min-val u-max-s u-max-val
                        v-min-s v-min-val v-max-s v-max-val)
  (new-uv-domain
   (make-interval u-min-s u-min-val u-max-s u-max-val)
   (make-interval v-min-s v-min-val v-max-s v-max-val)))


(define (domain-u-min-s uv-domain)
  (interval-min-s (uv-domain-u uv-domain)))

(define (domain-u-min-val uv-domain)
  (interval-min-val (uv-domain-u uv-domain)))

(define (domain-u-max-s uv-domain)
  (interval-max-s (uv-domain-u uv-domain)))

(define (domain-u-max-val uv-domain)
  (interval-max-val (uv-domain-u uv-domain)))


(define (domain-v-min-s uv-domain)
  (interval-min-s (uv-domain-v uv-domain)))

(define (domain-v-min-val uv-domain)
  (interval-min-val (uv-domain-v uv-domain)))

(define (domain-v-max-s uv-domain)
  (interval-max-s (uv-domain-v uv-domain)))

(define (domain-v-max-val uv-domain)
  (interval-max-val (uv-domain-v uv-domain)))


; cut

(define (cut-t-domain t-domain t-segments cut-fn)
  (let ((intervals (cut-interval (t-domain-t t-domain) t-segments cut-fn)))
    (map new-t-domain intervals)))

(define (cut-uv-domain uv-domain u-segments v-segments u-cut-fn v-cut-fn)
  (let ((u-intervals (cut-interval (uv-domain-u uv-domain) u-segments u-cut-fn))
        (v-intervals (cut-interval (uv-domain-v uv-domain) v-segments v-cut-fn)))
    (flatten
     (for/list ((u-interval u-intervals))
       (for/list ((v-interval v-intervals))
         (new-uv-domain u-interval v-interval))))))

(define (cut-domain domain n-domains cut-fn)
  (cond ((t-domain? domain)
         (cut-t-domain domain n-domains cut-fn))
        ((uv-domain? domain)
         (cut-uv-domain
          domain
          (first n-domains) (second n-domains)
          (first cut-fn) (second cut-fn)))
        (else
         (error 'cut-domain "Unhandled domain type"))))


; points

(define (points-t-domain
         t-domain
         n-points
         space-fn
         t-fn
         cut-fn)
  (map space-fn (points-interval (t-domain-t t-domain) n-points t-fn cut-fn)))

(define (points-uv-domain
         uv-domain
         u-points
         v-points
         space-fn
         u-fn
         v-fn
         u-cut-fn
         v-cut-fn)
  (flatten
   (for/list ((u-point (points-interval (uv-domain-u uv-domain) u-points u-fn u-cut-fn)))
     (for/list ((v-point (points-interval (uv-domain-v uv-domain) v-points v-fn v-cut-fn)))
       (space-fn u-point v-point)))))

(define (points-domain
         domain
         n-points
         space-fn
         t-fn
         cut-fn)
  (cond ((t-domain? domain)
         (points-t-domain
          domain
          n-points
          space-fn
          t-fn
          cut-fn))
        ((uv-domain? domain)
         (points-uv-domain
          domain
          (first n-points) (second n-points)
          space-fn
          (first t-fn) (second t-fn)
          (first cut-fn) (second cut-fn)))
        (else
         (error 'points-domain "Unhandled domain type"))))